home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Pr_lam.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  5.7 KB  |  157 lines  |  [TEXT/R*ch]
  1. local
  2.   open Mixture Const Prim Lambda Asynt;
  3. in
  4.  
  5. (* Printing lambda expressions for debugging purposes. *)
  6.  
  7. fun printPrimTest printer = fn
  8.     PTeq => msgString "eq"
  9.   | PTnoteq => msgString "noteq"
  10.   | PTnoteqimm a => (msgString "noteqimm "; printer a)
  11.   | PTlt => msgString "lt"
  12.   | PTle => msgString "le"
  13.   | PTgt => msgString "gt"
  14.   | PTge => msgString "ge"
  15. ;
  16.  
  17. val rec printPrim = fn
  18.     Pidentity => msgString "identity"
  19.   | Pget_global (qualid, stamp) =>
  20.       (msgString "get_global "; printQualId qualid;
  21.        msgString "/"; msgInt stamp)
  22.   | Pset_global (qualid, stamp) =>
  23.       (msgString "set_global "; printQualId qualid;
  24.        msgString "/"; msgInt stamp)
  25.   | Pdummy n => (msgString "dummy "; msgInt n)
  26.   | Pupdate => msgString "update"
  27.   | Ptest btest => (msgString "test:"; printBoolTest btest)
  28.   | Pmakeblock ctag => (msgString "makeblock "; printCTag ctag)
  29.   | Ptag_of => msgString "tag_of"
  30.   | Pfield n => (msgString "field "; msgInt n)
  31.   | Psetfield n => (msgString "setfield "; msgInt n)
  32.   | Pccall(name, arity) =>
  33.       (msgString "ccall"; msgInt arity;
  34.        msgString " "; msgString name)
  35.   | Praise => msgString "raise"
  36.   | Pnot => msgString "not"
  37.   | Paddint => msgString "unsaddint"
  38.   | Psubint => msgString "unssubint"
  39.   | Pmulint => msgString "unsmulint"
  40.   | Pdivint => msgString "unsdivint"
  41.   | Pmodint => msgString "unsmodint"
  42.   | Pandint => msgString "andint"
  43.   | Porint => msgString "orint"
  44.   | Pxorint => msgString "xorint"
  45.   | Pshiftleftint => msgString "shiftleftint"
  46.   | Pshiftrightintsigned => msgString "shiftrightintsigned"
  47.   | Pshiftrightintunsigned => msgString "shiftrightintunsigned"
  48.   | Pintoffloat => msgString "intoffloat"
  49.   | Pfloatprim fprim => (msgString "floatprim "; printFloatPrim fprim)
  50.   | Pstringlength => msgString "stringlength"
  51.   | Pgetstringchar => msgString "getstringchar"
  52.   | Psetstringchar => msgString "setstringchar"
  53.   | Pmakevector => msgString "makevector"
  54.   | Pvectlength => msgString "vectlength"
  55.   | Pgetvectitem => msgString "getvectitem"
  56.   | Psetvectitem => msgString "setvectitem"
  57.   | Psmlnegint => msgString "smlnegint"
  58.   | Psmlsuccint => msgString "smlsuccint"
  59.   | Psmlpredint => msgString "smlpredint"
  60.   | Psmladdint => msgString "smladdint"
  61.   | Psmlsubint => msgString "smlsubint"
  62.   | Psmlmulint => msgString "smlmulint"
  63.   | Psmldivint => msgString "smldivint"
  64.   | Psmlmodint => msgString "smlmodint"
  65.   | Pmakerefvector => msgString "makerefvector"
  66.   | Patom t     => (msgString "atom "; msgInt t)
  67.   | Psmlquotint => (msgString "smlquotint")
  68.   | Psmlremint  => (msgString "smlremint")
  69.   | Pclosure (lbl,sz) => 
  70.       (msgString "closure "; msgInt lbl; msgString " "; msgInt sz)
  71.   | Pswap => msgString "swap"
  72.  
  73. and printFloatPrim = fn
  74.     Pfloatofint => msgString "floatofint"
  75.   | Psmlnegfloat => msgString "smlnegfloat"
  76.   | Psmladdfloat => msgString "smladdfloat"
  77.   | Psmlsubfloat => msgString "smlsubfloat"
  78.   | Psmlmulfloat => msgString "smlmulfloat"
  79.   | Psmldivfloat => msgString "smldivfloat"
  80.  
  81. and printBoolTest = fn
  82.     Peq_test => msgString "eq_test"
  83.   | Pnoteq_test => msgString "noteq_test"
  84.   | Pint_test test => printPrimTest msgInt test
  85.   | Pfloat_test test => printPrimTest msgReal test
  86.   | Pstring_test test => printPrimTest msgString test
  87.   | Pword_test test => printPrimTest msgWord test
  88.   | Pnoteqtag_test ct =>
  89.       (msgString "noteqtag_test "; printCTag ct)
  90. ;
  91.  
  92. fun printLam lam =
  93.   case lam of
  94.     Lvar i => (msgString "var:"; msgInt i)
  95.   | Lconst cst => printStrConst cst
  96.   | Lapply(func, args) =>
  97.       (msgString "(app "; printLam func; msgString " ";
  98.        printSeq printLam " " args; msgString ")")
  99.   | Lfn lam => (msgString "(fn "; printLam lam; msgString ")")
  100.   | Llet(args, scope) =>
  101.       (msgString "let "; printSeq printLam " " args;
  102.        msgString " in "; printLam scope; msgString " end")
  103.   | Lletrec(args, scope) =>
  104.       (msgString "letrec "; printSeq printLam " " args;
  105.        msgString " in "; printLam scope; msgString " end")
  106.   | Lprim(prim, args) =>
  107.       (msgString "(prim ("; printPrim prim; msgString ") ";
  108.        printSeq printLam " " args; msgString ")")
  109.   | Lcase(arg, clauses) =>
  110.       (msgString "(case "; printLam arg; msgString " of ";
  111.        printSeq printClause " " clauses; msgString ")")
  112.   | Lswitch(n, arg, clauses) =>
  113.       (msgString "(switch:"; msgInt n; msgString " ";
  114.        printLam arg; msgString " of ";
  115.        printSeq printSwClause " " clauses; msgString ")")
  116.   | Lstaticfail => msgString "staticfail"
  117.   | Lstatichandle(lam1, lam2) =>
  118.       (msgString "("; printLam lam1; msgString " statichandle ";
  119.        printLam lam2; msgString ")")
  120.   | Lhandle(lam1, lam2) =>
  121.       (msgString "("; printLam lam1; msgString " handle ";
  122.        printLam lam2; msgString ")")
  123.   | Lif(lam0, lam1, lam2) =>
  124.       (msgString "if"; printLam lam0; msgString " then (";
  125.        printLam lam1; msgString ") else "; printLam lam2)
  126.   | Lseq(lam1, lam2) =>
  127.       (msgString "("; printLam lam1; msgString "; "; printLam lam2;
  128.        msgString ")")
  129.   | Lwhile(lam1, lam2) =>
  130.       (msgString "while "; printLam lam1; msgString " do ";
  131.        printLam lam2)
  132.   | Landalso(lam1, lam2) =>
  133.       (msgString "("; printLam lam1; msgString " andalso ";
  134.        printLam lam2; msgString ")")
  135.   | Lorelse(lam1, lam2) =>
  136.       (msgString "("; printLam lam1; msgString " orelse ";
  137.        printLam lam2; msgString ")")
  138.   | Lunspec =>
  139.       msgString "unspec"
  140.   | Lshared(lam_ref, lbl) =>
  141.       (msgString "(shared:"; msgInt (!lbl); msgString " ";
  142.        printLam (!lam_ref); msgString ")")
  143.   | Lassign(i,lam) => (msgString "assign:"; msgInt i;
  144.                        msgString " <- "; printLam lam)
  145.  
  146. and printClause (scon, lam) =
  147.   (printSCon scon; msgString " : "; printLam lam)
  148.  
  149. and printExClause (lam1, lam2) =
  150.   (printLam lam1; msgString " : "; printLam lam2)
  151.  
  152. and printSwClause (ct, lam) =
  153.   (printCTag ct; msgString " : "; printLam lam)
  154. ;
  155.  
  156. end;
  157.